(define *env* '())
(define env-init-compiletime '())
(define env-global-compiletime '())
(define env-global-runtime (make-vector 200 '()))

(define (init-core-form)
  (define (add-syntax name)
    (let ((value `(,name predefined syntax . ,name)))
      (set! env-init-compiletime (cons value env-init-compiletime))))
  (add-syntax 'begin)
  (add-syntax 'if)
  (add-syntax 'set!)
  (add-syntax 'lambda)
  (add-syntax 'quote))

(define (init-primitive-form)
  (define (add-primitive name address arity)
    (let ((value `(,name predefined primitive ,address . ,arity)))
      (set! env-init-compiletime (cons value env-init-compiletime))))
  (add-primitive 'cons cons 2)
  (add-primitive '+ + 2))
(define (init)
  (init-core-form)
  (init-primitive-form))

(define (global-define name value)
  (let ((index (length env-global-compiletime)))
    (set! env-global-compiletime 
	  (cons (cons name (cons 'global index)) env-global-compiletime))
    (vector-set! env-global-runtime index value)))
(global-define 'test 35)

(define (CONSTANT v)
  (lambda () v))

(define (PREDEFINED v)
  (lambda () v))

(define (GLOBAL-REF i)
  (lambda ()
    (vector-ref env-global-runtime i)))

(define (ALTERNATIVE v1 v2 v3)
  (lambda ()
    (if (v1) (v2) (v3))))
(define (SEQUENCE v1 v2)
  (lambda ()
    (v1) (v2)))
(define (GLOBAL-SET i v)
  (lambda ()
    (vector-set! env-global-runtime i (v))))
(define (SHALLOW-ARGUMENT-REF j)
  (lambda ()
    (let ((vec (car *env*)))
      (vector-ref vec j))))
(define (SHALLOW-ARGUMENT-SET j value)
  (lambda ()
    (let ((vec (car *env*)))
      (vector-set! vec j (value)))))
(define (DEEP-ARGUMENT-SET i j value)
  (define (deep-update frame i j v)
    (if (= i 0)
	(vector-set! (car frame) j v)
	(deep-update (cdr frame) (- i 1) j v)))
  (lambda ()
    (deep-update *env* i j (value))))
(define (DEEP-ARGUMENT-REF i j)
  (define (deep-fetch frame i j v)
    (if (= i 0)
	(vector-ref (car frame) j)
	(deep-fetch (cdr frame) (- i 1) j)))
  (lambda ()
    (deep-fetch *env* i j)))
(define (CALL0 address)
  (lambda () (address)) )

(define (CALL1 address m1)
  (lambda () (address (m1))) )

(define (CALL2 address m1 m2)
  (lambda () (let ((v1 (m1))) 
               (address v1 (m2)) )) )

(define (CALL3 address m1 m2 m3)
  (lambda () (let* ((v1 (m1))
                    (v2 (m2)) )
               (address v1 v2 (m3)) )) )
;;函数调用规则：由调用者准备好参数。由被调函数切换环境绑定。由调用者恢复环境
(define (CLOSURE code arity)
  (lambda ()
    (define (function frame)
      (if (= arity (vector-length frame))
	  (begin (set! *env* (cons frame *env*))
		 (code))
	  (runtime-wrong "Incorrect number of arity")))
    (cons function *env*)))
(define (invoke closure arg)
  (let ((function (car closure))
	(frame (cdr closure)))
    (function arg)))
(define (TAIL-CALL op arg)
  (lambda ()
    (invoke (op) (arg))))
(define (CALL op arg)
  (lambda ()
    (let ((save *env*))
      (let ((result (invoke (op) (arg))))
	(set! *env* save)
	result))))
(define (STORE-ARGUMENT m m* pos)
  (lambda ()
    (let ((v (m))
	  (vec (m*)))
      (vector-set! vec pos v)
      vec)))
(define (ALLOCATE-FRAME size)
  (lambda ()
    (make-vector size)))

(define (local-variable? env i name)
  (and (pair? env)
       (let scan ((names (car env))
		  (j 0))
	 (cond ((pair? names)
		(if (eqv? (car names) name)
		    `(local ,i . ,j)
		    (scan (cdr names) (+ j 1))))
	       ((null? names)
		(local-variable? (cdr env) (+ i 1) name))
	       ((eqv? name names) `(local ,i . ,j))))))

(define (global-variable? list name)
  (let ((find (assv name list)))
    (and find (cdr find))))

(define (compute-kind env name)
  (or (local-variable? env 0 name)
      (global-variable? env-global-compiletime name)
      (global-variable? env-init-compiletime name)))

(define (compile-wrong msg)
  (display msg))
(define (runtime-wrong msg)
  (display msg))

(define (compile-variable form env tail?)
  (let ((kind (compute-kind env form)))
    (if kind
	(case (car kind)
	  ((local)
	   (let ((i (cadr kind))
		 (j (cddr kind)))
	     (if (= i 0)
		 (SHALLOW-ARGUMENT-REF j)
		 (DEEP-ARGUMENT-REF i j))))
	   ((global)
	    (let ((i (cdr kind)))
	      (GLOBAL-REF i)))
	   ((predefined)
	    (let ((v (cdr kind)))
	      (PREDEFINED v))))
	  (compile-wrong "No such variable"))))

(define (compile-quote v)
  (CONSTANT v))
(define (compile-if etest etrue efalse env tail?)
  (let ((v1 (compile etest env #f))
	(v2 (compile etrue env tail?))
	(v3 (compile efalse env tail?)))
    (ALTERNATIVE v1 v2 v3)))
(define (compile-begin form env tail?)
  (if (pair? form)
      (if (pair? (cdr form))
	  (let ((v1 (compile (car form) env #f))
		(v2 (compile-begin (cdr form) env tail?)))
	    (SEQUENCE v1 v2))
	  (compile (car form) env tail?))
      (CONSTANT (begin))))
(define (compile-set name form env tail?)
  (let ((value (compile form env #f))
	(kind (compute-kind env name)))
    (if kind
	(case (car kind)
	  ((local) 
	   (let ((i (cadr kind))
		 (j (cddr kind)))
	     (if (= i 0)
		 (SHALLOW-ARGUMENT-SET j value)
		 (DEEP-ARGUMENT-SET i j value))))
	  ((global) 
	   (GLOBAL-SET (cdr kind) value))
	  ((predefined) 
	   (compile-wrong "Immutable predefined variable")))
	(compile-wrong "No such variable"))))
(define (extend-env env names)
  (cons names env))
(define (compile-lambda names body env tail?)
  (let* ((arity (length names))
	 (new-env (extend-env env names))
	 (v (compile-begin body new-env #t)))
    (if (procedure? v)
	(CLOSURE v arity)
	(compile-wrong "Compile lambda error:can't compile body of lambda"))))
(define (compile-argument-recurse e e* env size pos tail?)
  (let ((v (compile e env #f))
	(v* (compile-argument e* (- size 1) (+ pos 1) env tail?)))
    (STORE-ARGUMENT v pos v*)))
(define (compile-argument arg pos env tail?)
    (if (pair? arg)
	(let ((v (compile (car arg) env #f))
	      (v* (compile-argument (cdr arg) (+ pos 1) env tail?)))
	  (STORE-ARGUMENT v v* pos))
	(ALLOCATE-FRAME pos)))

(define (compile-regular-application first other env tail?)
  (let ((op (compile first env tail?))
	(arg (compile-argument other 0 env tail?)))
    (if tail? (TAIL-CALL op arg) (CALL op arg))))

(define (compile-primitive-call info other env tail?)
  (let ((address (car info))
	(arity (cdr info)))
    (if (= arity (length other))
	(case arity
	  ((0) (CALL0 address))
	  ((1) 
	   (let ((m1 (compile (car other) env #f)))
	     (CALL1 address m1)))
	  ((2)
	   (let ((m1 (compile (car other) env #f))
		 (m2 (compile (cadr other) env #f)))
	     (CALL2 address m1 m2)))
	  ((3)
	   (let ((m1 (compile (car other) env #f))
		 (m2 (compile (cadr other) env #f))
		 (m3 (compile (caddr other) env #f)))
	     (CALL3 address m1 m2 m3)))
	  (else 
	   (compile-wrong "support atmost 3 arity privitive now!")))
	(compile-wrong "Incorrect arity for primitive"))))


(define (compile-application first other env tail?)
  (cond ((symbol? first)
	 (let ((kind (compute-kind env first)))
	   (or
	    (and (pair? kind) (eq? (car kind) 'predefined)
		 (let ((desc (cdr kind)))
		   (case (car desc)
		     ((syntax) 
		      (case (cdr desc)
			((quote) (compile-quote (car other)))
			((if) (compile-if (car other) (cadr other) (caddr other) env tail?))
			((begin) (compile-begin other env tail?))
			((set!) (compile-set (car other) (cadr other) env tail?))
			((lambda) (compile-lambda (car other) (cdr other) env tail?))))
		     ;;		       ((define) (compile-define other))))
		     ((primitive) 
		      (compile-primitive-call (cdr desc) other env tail?))
		     ((macro) '()))))
	    (compile-regular-application first other env tail?))))
	;;	 ((and (pair? op) (eq? (car op) 'lambda))
	;;	  (compile-closed-application op arg env tail?))
	(else (compile-regular-application first other env tail?))))

(define (compile form env tail?)
  (if (pair? form)
      (compile-application (car form) (cdr form) env tail?)
      (if (symbol? form)
	  (compile-variable form env tail?)
	  (CONSTANT form))))